use utf8;
use strict;

use Math::Cartesian::Product;
use List::Compare;
use List::MoreUtils qw/ uniq /;
use Data::Dumper;
use Clone qw(clone);

my %restr_types = ( 1 => "must", 0 => "may", 2 => "cant" );
my %obj_types = ( 0 => "lemma-lemma", 1 => "lemma-form", 3 => "form-form" );

binmode(STDOUT, ":encoding(utf-8)");
binmode(STDERR, ":encoding(utf-8)");

my $rg = read_grm_model(); 

my $rls = undef; #build_lattices($rg); # lattice store
my $max_lemmata = 100;
#my $rd = 
process_dict($ARGV[0], \&process_lemma);

sub process_lemma {
  my $rl = shift;

#  my $rbl = find_best_lattice($rl);
#  print STDERR $rl->{text} . " " . $rbl->[0] . "\n";

  my $rlattice = build_lattice($rl);

  my $re = check_lemma_against_lattice($rl, $rlattice);

  if ($#{$re} >= 0) {
    foreach my $e (@{$re}) {
      print join("\t", ("ERROR", $rl->{id}, $rl->{text}, $e->{type}, $e->{descr}, "\n"));
    }
  }

#  $max_lemmata -= 1;
#  if (0 == $max_lemmata) {
#    die;
#  }
}

sub build_lattice {
  my $rl = shift;

  # шаг 1: выбрать категории, по которым будем строить решётку
  my @categories = find_categories($rl->{gram});

  # шаг 2: строим решётку
  my @lattice = ();

  if ($#categories >= 0) {
    my @category_value_set;
    foreach my $cat (@categories) {
      push @category_value_set, $rg->{gram}->{$cat}->{children};
    }

    @lattice = cartesian { check_compatibility($rg->{gram}, \@_) } @category_value_set;
  }

#  temporary
#  print STDERR "LEMMA " . $rl->{text} . " " . gs2str([keys %{$rl->{gram}}]) . "\n";
#  print STDERR lattice_to_string(\@lattice) . "\n";
#  print STDERR "\n";

  # шаг 3: добавляем категории леммы и учитываем правила вывода внутри форм
  my @extended_lattice;
  foreach my $rcell (@lattice) {
    my $r = extend_gram_set($rcell);
    push @extended_lattice, @{$r};
  }

#  temporary
#  print STDERR "LEMMA " . $rl->{text} . " " . gs2str([keys %{$rl->{gram}}]) . "\n";
#  print STDERR lattice_to_string(\@extended_lattice) . "\n";
#  print STDERR "\n";

  # шаг 4: удаляем из решётки невозможные элементы
  my @cells;
  foreach my $rcell (@extended_lattice) {
    apply_restrictions_to_gram_set($rcell);
    push @cells, join(" ", @{$rcell});
  }

  my %uniq_cells = map {$_ => 1} @cells;
  my @final_lattice;

  foreach my $k (keys %uniq_cells) {
    my @grm = split(/\s+/, $k);
    if (1 == apply_restrictions_to_gram_set(\@grm, $rl->{gram})) {
      push @grm, keys(%{$rl->{gram}});
      push @final_lattice, \@grm;
    }
  }

#  temporary
#  print STDERR "LEMMA " . $rl->{text} . " " . gs2str([keys %{$rl->{gram}}]) . "\n";
#  print STDERR lattice_to_string(\@final_lattice) . "\n";
#  print STDERR "\n";

  return \@final_lattice;
}

sub check_compatibility {
  my ($rlgram, $rfgram) = @_;

  return 1;
}

sub find_categories {
  my ($rseeds) = @_;
  my @categories;
  #my %hseeds = map {$_ => 1} @{$rseeds};
  my $key = gs2str([keys %{$rseeds}]);

  foreach my $rid (keys %{$rg->{rules}}) {
    my $rr = $rg->{rules}->{$rid};
    if (exists $rseeds->{$rg->{rules}->{$rid}->{if}}) {
#      print STDERR "rule $rid is applicable to $key\n";

      if ("must" eq $rr->{type}) {
        if ("lemma-form" eq $rr->{obj} && 0 == $rr->{auto}) {
         
#          print STDERR "$key lattice includes " . $rr->{then} . "\t" . join(" ", @{$rg->{gram}->{$rr->{then}}->{children}}) . "\n";
          push @categories, $rr->{then};
        }
      }
    }
  }  

  return @categories;
}

sub gs2str {
  my ($rgram) = @_;
  
  return join(" ", @{$rgram});
}

sub lattice2str {
  my ($rlattice) = @_;
  my $str;

  #print STDERR Dumper($rlattice);
  foreach my $rcell (@{$rlattice}) {
    $str .= gs2str($rcell) . "\n";
  }
  
  return $str;
}


sub update_lattice_for_lemma {
  my ($rl, $rbl) = @_;

  return $rbl;
}

sub check_lemma_against_lattice {
  my ($rl, $rbl) = @_;
  my @errors;
# my @cells = @{$rbl};
  my %cell2count = map {join(" ", @{$_}) => 0} @{$rbl};
  my @cells = keys %cell2count;

#  print $#cells . "\n";
  foreach my $c (@cells) {
#   my %cell_g2c = map {$_ => 0} split(/\s+/, $c);
#    print STDERR "trying " . $c . "\n";
    my $max = 0;
    my $r_best_form = undef;

    foreach my $rf (@{$rl->{forms}}) {
      my %form_g2c = map {$_ => 1} keys %{$rf->{gram}};
      my %cell_g2c = map {$_ => 0} split(/\s+/, $c);

      foreach my $g (keys %form_g2c) {
        if (exists $cell_g2c{$g}) {
          $cell_g2c{$g} = 1;
#          print STDERR "$g +\n";
        } elsif (exists $cell_g2c{$rg->{gram}->{$g}->{parent}}) {
          # если граммема является вариантом другой граммемы (gen2 является вариантом gent)
          # print STDOUT "COOL: $g is child of " . $rg->{gram}->{$g}->{parent} . "\n";
          $cell_g2c{$rg->{gram}->{$g}->{parent}} = 1;
          
        }
      }

#print STDERR Dumper(\%cell_g2c) . "\n";

      my $count = 0;
      foreach my $g (keys %cell_g2c) {
        $count += $cell_g2c{$g};
      }

#print STDERR "count = " . $count . "\n";
#print STDERR "scalar keys %cell_g2c = " . scalar(keys %cell_g2c) . "\n";
      if ($count > $max) {
        $r_best_form = $rf;
        $max = $count;
      }
#    }
#
#    if (defined($r_best_form)) {
#      $cell2count{$c} += 1;
#    }

      if ($count == (scalar(keys(%cell_g2c)) - scalar(keys(%{$rl->{gram}})))) {
#        print STDERR "found " . join(" ", keys %form_g2c) . "\n";;
        $cell2count{$c} += 1;
      } else {
#        print STDERR "DEBUG \"" . join(" ", keys %form_g2c) . "\" with \"" . join(" ", keys %cell_g2c) . "\" got $count\n";
      }
    }
#die;
  }

#print STDERR Dumper(\%cell2count) . "\n";
#die;
  foreach my $c (keys %cell2count) {
    if ($cell2count{$c} < 1) {
      my %e;
      $e{type} = "missing";
      $e{descr} = "\'$c\'"; # . join(" ", @{$c});
      push @errors, \%e;
    }
  }

  return \@errors;
}

sub find_best_lattice {
  my ($rl) = @_;

  # пересечь набор граммем леммы со всеми ключами решёток
  # выборать ту решётку, у которой пересечение больше
  my %lattice_to_score;
  my $best_lattice_ref;
  
  foreach my $lk (keys %{$rls}) {
    my @lattice_key = sort(split(" ", $lk));
    my @lemma_gram = keys %{$rl->{gram}};
    my $lc = List::Compare->new(\@lattice_key, \@lemma_gram);
    print STDERR "intersection of " . join(" ", @lattice_key) . " and " . join(" ", @lemma_gram) . " is ";
    print STDERR join(" ", $lc->get_intersection) . " " . scalar($lc->get_intersection) . "\n";
    $lattice_to_score{$lk} = scalar($lc->get_intersection);
  }

  my $best_lattice_key;
  foreach my $k (sort {$lattice_to_score{$b} <=> $lattice_to_score{$a}} keys %lattice_to_score) {
    $best_lattice_ref = clone($rls->{$k});
    $best_lattice_key = $k;
    print STDERR "best is $k with " . $lattice_to_score{$k} . "\n";
    last;
  }

  my @lattice_gram = sort(split("\s+", $best_lattice_key));
  my @lemma_gram = sort(keys %{$rl->{gram}});
  my $lc = List::Compare->new(\@lattice_gram, \@lemma_gram);
  my @not_accounted_lemma_gram = $lc->get_Ronly;

  my %best_lattice_gram = map {$_ => 1} @lattice_gram;
  foreach my $g (keys %{$rl->{gram}}) {
    if (! exists $best_lattice_gram{$g}) {
      print STDERR "missing gram \"$g\" in best lattice key\n";
      if (exists $rg->{rules_by_if}->{$g}) {
        # let's try to apply all of them
#        print STDERR "trying to apply additional rules to \"$best_lattice_key\" due to \"$g\"\n";
        foreach my $rid (@{$rg->{rules_by_if}->{$g}}) {
          my $rr = $rg->{rules}->{$rid};
          if ("must" eq $rr->{type}) {
#            print STDERR "\ttrying to apply MUST rule $rid: " . $rr->{then}. "\n";
          } elsif ("cant" eq $rr->{type}) {
            if ("lemma-form" eq $rr->{obj}) {
#              print STDERR "\ttrying to apply CANT LEMMA-FORM rule $rid: " . $rr->{then}. "\n";
            } elsif ("form-form" eq $rr->{obj}) {
#              print STDERR "\ttrying to apply CANT FORM-FORM rule $rid: " . $rr->{then}. "\n";

            }
          }
        }
      }
    }
  }

  print STDERR "nalg: " . join(" ", @not_accounted_lemma_gram) . "\n";
  if ($#not_accounted_lemma_gram > 0 && defined($best_lattice_ref)) {
    #print STDERR "$best_lattice_key\n";
    #print STDERR Dumper($best_lattice_ref);
    foreach my $rf (@{$best_lattice_ref}) {
       push @{$rf}, @not_accounted_lemma_gram;
       @{$rf} = sort {$a cmp $b} (@{$rf});
    }

    #my @updated_lattice = cartesian {1} @not_accounted_lemma_gram, $best_lattice_ref;
    my @new_lattice;
    foreach my $ra (@{$best_lattice_ref}) {
      if (1 == apply_restrictions_to_gram_set($ra)) {
        push @new_lattice, $ra;
      }
    }

    print STDERR Dumper(\@new_lattice);
    return \@new_lattice;
  }
  
  #$rbl = $rls->{"NOUN"};

  return $best_lattice_ref;
}

sub build_lattice_for_POST {
  my ($rg, $post) = @_;
  my @categ_value_set;
#  my @categ;
#  my @lattice;
#  my $grm_id = $rg->{gram}->{$post}->{gram_id};

  foreach my $rid (keys %{$rg->{rules}}) {
    my $rr = $rg->{rules}->{$rid};
    if ($post eq $rg->{rules}->{$rid}->{if}) {
#      print STDERR "rule $rid is applicable to $post\n";

      if ("must" eq $rr->{type}) {
        if ("lemma-form" eq $rr->{obj} && 0 == $rr->{auto}) {
         
#          print STDERR "$post lattice includes " . $rr->{then} . "\t" . join(", ", @{$rg->{gram}->{$rr->{then}}->{children}}) . "\n";
#          push @categ, $rr->{then};
          push @categ_value_set, $rg->{gram}->{$rr->{then}}->{children};
        }
      }

    }
  }  

  if ($#categ_value_set < 0) {
    return undef;
  }

  push @categ_value_set, [$post];

  print STDERR Dumper(\@categ_value_set) . "\n";

  my @l = cartesian {1} @categ_value_set ;
  my %fl;
  foreach my $ra (@l) {
    my $rara = extend_gram_set($ra);
    foreach my $rgs (@{$rara}) {
      my %hgs = map { $_ => 1 } @{$rgs};
      my @gs = keys %hgs;
      $rgs = \@gs;
#      print "before apply_restrictions_to_gram_set: " . join(" ", @{$rgs}) . "\n";
      apply_restrictions_to_gram_set($rgs);
#      print "after apply_restrictions_to_gram_set:  " . join(" ", @{$rgs}) . "\n";
      $fl{join(" ", @{$rgs})} += 1;
    }
  }

  my @final_lattice;
  foreach my $k (keys %fl) {
    push @final_lattice, [ split(/\s+/, $k) ];
  }

  return \@final_lattice;
}

sub extend_gram_set {
  my $ra = shift;
  my %ha = map { $_ => 1 } @{$ra};
  my @ags;

#  print "=> extend_gram_set\n";
#  print "   " . join(" ", @{$ra}) . "\n";

  foreach my $rid (keys %{$rg->{rules}}) {
    my $rr = $rg->{rules}->{$rid};
    if ("must" eq $rr->{type} && "form-form" eq $rr->{obj} && exists($ha{$rr->{if}})) {

      my $try_next_rule = 0;

      foreach my $ch (@{$rg->{gram}->{$rr->{then}}->{children}}) {
#        print "check $ch in \"" . join(" ", @{$ra}) . "\"\n";
        if (exists($ha{$ch})) { 
          $try_next_rule = 1;
          next;
        }
      }
      if (1 == $try_next_rule) {
        next;
      }

#      if ($#{$ra} > 4) {return;}
  
#      print "in gram set \"" . join(" ", @{$ra}) . "\" \"" . $rr->{if} . "\" requires \"" . $rr->{then} . "\" due to rule $rid\n";
      my @l = cartesian {1} [ $ra ], $rg->{gram}->{$rr->{then}}->{children};
#     foreach my $aa (@l) { print "\'" . join(" ", @{$aa}) . "\' "; }
#      print "\n";
 
      foreach my $aa (@l) {
        my $rara = extend_gram_set($aa);
        foreach my $raa (@{$rara}) {
          push @ags, $raa;
        }
      }
    }
  } 

  if ($#ags < 0) {
    push @ags, $ra;
  } # else {
#    print "ags size is " .$#ags . "\n";
#    print "ags: " . join(" ", @ags) . "\n";
#  }

#  print "<= extend_gram_set\n"; 
  return \@ags;
}

sub apply_restrictions_to_gram_set {
  my ($ra, $rlg) = @_;
  my %ha = map { $_ => 1 } @{$ra};
  my $retval = 1;

  foreach my $rid (keys %{$rg->{rules}}) {
    my $rr = $rg->{rules}->{$rid};
    if ("cant" eq $rr->{type} && "form-form" eq $rr->{obj} && 
        exists($ha{$rr->{if}}) && exists($ha{$rr->{then}})) {
#      print STDERR "in gram set \"" . join(" ", @{$ra}) . "\" \"" . $rr->{if} . "\" isn't compatible with \"" . $rr->{then} . "\" due to F/F rule $rid\n";
      delete $ha{$rr->{then}};
    } elsif ("cant" eq $rr->{type} && "lemma-form" eq $rr->{obj} && 
          exists($rlg->{$rr->{if}}) && exists($ha{$rr->{then}})) {
#      print STDERR "in gram set \"" . join(" ", @{$ra}) . "\" \"" . $rr->{if} . "\" isn't compatible with \"" . $rr->{then} . "\" due to L/F rule $rid\n";
      #delete $ha{$rr->{then}};
      return 0;
      $retval = 0;
    }
  }

  @{$ra} = keys %ha;
  return $retval;
}

sub apply_one_restriction_to_gram_set {
  #my
  # TODO 
}

sub build_lattices {
  my ($rg) = @_;
  my %lattice_store;
  
  foreach my $grm (keys %{$rg->{gram}}) {
#    print STDERR "$grm\n";
    if ("POST" eq $rg->{gram}->{$grm}->{parent}) {
      print STDERR "$grm is POST tag\n";
      my $rl = build_lattice_for_POST($rg, $grm);
      print STDERR "----- -----\n";
      print STDERR lattice_to_string($rl, $rg) . "\n";
      print STDERR "----- -----\n";

      $lattice_store{$grm} = $rl;
#      return;
    }
  }

  return \%lattice_store;
}

sub lattice_to_string {
  my ($rl) = @_;
  my %v2c;
  my %c;
  my @categ;

  foreach my $f (@{$rl}) {
    foreach my $v (@{$f}) {
      $v2c{$v} = $rg->{gram}->{$v}->{parent};
      $c{$v2c{$v}} += 1;
    } 
  }

  @categ = sort {$c{$b} <=> $c{$a}} keys %c;

  my @str;

  foreach my $f (@{$rl}) {
    my %values;
    my @other_gram;
    my $s;
    foreach my $v (@{$f}) {
      if ("ROOT" eq $c{$v}) {
        push @other_gram, $v;
      } else {
        $values{$v2c{$v}} = $v;
      }
    }
#    $s .= keys %values;

    foreach my $cat (@categ) {
      if (exists $values{$cat}) {
        $s .= $values{$cat} . " ";
      } else {
        $s .= "     ";
      }
    }

    $s .= join(" ", @other_gram);
    push @str, $s;
  }  
    
  return join("\n", sort(@str));
}

sub read_grm_model {
  my %g;

  $g{id}->{0} = "ROOT";

  open(F, "< gram.txt");
  binmode(F, ":encoding(utf-8)");
  while (<F>) {
    chomp $_;
    my ($gram_id, $parent_id, $inner_id, $outer_id, $gram_descr, $orderby) = split(/\s+/, $_);
    $g{gram}->{$inner_id}->{id} = $inner_id;
    $g{gram}->{$inner_id}->{parent_id} = $parent_id;
    if (! exists $g{id}->{$parent_id}) { die "unknown grammem with id $parent_id"; }
    $g{gram}->{$inner_id}->{parent} = $g{id}->{$parent_id};
    $g{gram}->{$inner_id}->{gram_id} = $gram_id;
    $g{gram}->{$inner_id}->{outer_id} = $outer_id;
    $g{gram}->{$inner_id}->{gram_descr} = $gram_descr;
    $g{gram}->{$inner_id}->{orderby} = $orderby;
    $g{id}->{$gram_id} = $inner_id;
  }
  close(F);

  open(F, "< gram_restrictions.txt");
  binmode(F, ":encoding(utf-8)");
  while (<F>) {
    chomp $_;
    my ($restr_id, $if_id, $then_id, $restr_type, $obj_type, $auto) = split(/\s+/, $_);
    $g{rules}->{$restr_id}->{if} = $g{id}->{$if_id};
    $g{rules}->{$restr_id}->{then} = $g{id}->{$then_id};
    if (! exists $restr_types{$restr_type}) { die "can't parse $_ due to restr_type"; }
    $g{rules}->{$restr_id}->{type} = $restr_types{$restr_type};
    if (! exists $obj_types{$obj_type}) { die "can't parse $_ due to obj_type"; }
    $g{rules}->{$restr_id}->{obj} = $obj_types{$obj_type};
    $g{rules}->{$restr_id}->{auto} = $auto;
    
    push @{ $g{rules_by_if}->{$g{id}->{$if_id}} }, $restr_id;
  }
  close(F);

#  $g{rules}->{555555}->{if} = "Sgtm";
#  $g{rules}->{555555}->{then} = "plur";
#  $g{rules}->{555555}->{type} = "cant";
#  $g{rules}->{555555}->{obj} = "lemma-form";
#  $g{rules}->{555555}->{auto} = 0;

#  $g{rules}->{555556}->{if} = "Pltm";
#  $g{rules}->{555556}->{then} = "sing";
#  $g{rules}->{555556}->{type} = "cant";
#  $g{rules}->{555556}->{obj} = "lemma-form";
#  $g{rules}->{555556}->{auto} = 0;


  foreach my $grm (keys %{$g{gram}}) {
    if (0 != $g{gram}->{$grm}->{parent_id}) {
      push @{$g{gram}->{$g{gram}->{$grm}->{parent}}->{children}}, $grm;
    }
  }

  return \%g;
}

sub process_dict {
  my ($fn, $rf, $rg) = @_;
#  my %d;

  if ($fn =~ /\.bz2$/) {
    open(F, "bzcat $fn |") || die "can't open pipe \"bzcat $fn \"";
  } else {
    open(F, "< $fn") || die "can't open $fn";
  }
  binmode(F, ":encoding(utf-8)");
  while (<F>) {
    chomp $_;
    if ($_ =~ /^\s*<lemma id=\"(\d+)\" rev=\"(\d+)\">(<l.*?)<\/l>(<f.*?)<\/lemma>/) {
      #print $1 . "\n";
      my (%lemma, $lt, $ft);

      ($lemma{id}, $lemma{rev}, $lt, $ft) = ($1, $2, $3, $4);

      if ($lt =~ /<l t=\"([^\"]+?)\">/) {
        $lemma{text} = $1;
      } else {
        die "can't parse \"$lt\"";
      }

      while ($lt =~ /<g v=\"([^\"]+?)\"/g) {
        $lemma{gram}->{$1} += 1;
      }

      while ($ft =~ /<f t=\"([^\"]+?)\">(.*?)<\/f>/g) {
        my %form;
        $form{text} = $1;
        my $gt = $2;
        while ($gt =~ /<g v=\"([^\"]+?)\"/g) {
          $form{gram}->{$1} += 1;
        }

        push @{$lemma{forms}}, \%form;
      }

      $rf->(\%lemma);
    } elsif ($_ =~ /^\s*<grammem parent=\"([^\"]+)\">([^<]+)<\/grammem>/) {
      my ($parent, $gram) = ($1, $2);
      if (0 == length($parent)) {
        $parent = "ROOT";
      }
#      $rg->{gram}->{$gram}->{parent}->$parent;
    }
  }
  close(F);

#  return \%d;
}
